perm filename SCCPP.IL[TIM,LSP] blob sn#679556 filedate 1982-09-29 generic text, type T, neo UTF8
(FILECREATED "29-Sep-82 21:31:11" <CSD.BENNETT>RPG..9 6396   


     changes to:  MAKE-POSSIBILITY-1 MAKE-POSSIBILITY-2

     previous date: "29-Sep-82 21:10:24" <CSD.BENNETT>RPG..8)


(PRETTYCOMPRINT RPGCOMS)

(RPAQQ RPGCOMS ((FNS * RPGFNS)
		(VARS * RPGVARS)
		(BLOCKS * RPGBLOCKS)))

(RPAQQ RPGFNS (PAIRS PAIRS1 PAIRS2 MAKE-POSSIBILITY-1 
		     MAKE-POSSIBILITY-2 PAIRX PAIRY))
(DEFINEQ

(PAIRS
  [LAMBDA (X Y MUST-APPEAR FUN APPLY-CONSTRAINTS CONSTRAINTS NIL-PAIRS)         (* jsb: "29-Sep-82 20:55")
    ([LAMBDA (XXX)
	(MAPCONC XXX (FUNCTION PAIRX]										       |
      (MAPCAR [COND
		((ILESSP (LENGTH X)
			 (IPLUS (COND
				  (NIL-PAIRS 1)
				  (T 0))
				(LENGTH Y)))
		  (PAIRS1 (MAKE-POSSIBILITY-1 X Y FUN APPLY-CONSTRAINTS CONSTRAINTS NIL-PAIRS)))
		(T (PAIRS2 (MAKE-POSSIBILITY-2 Y X FUN APPLY-CONSTRAINTS CONSTRAINTS NIL-PAIRS]
	      (FUNCTION (LAMBDA (I)
		  (CDR I])

(PAIRS1
  [LAMBDA (L)                                   (* edited: 
						"29-Sep-82 21:08")
    (COND
      [(NULL L)							       |
	(QUOTE ((NIL]						       |
      (T
	([LAMBDA (CAND POSS)
	    (MAPCONC
	      (PAIRS1 (CDR L))
	      [FUNCTION (LAMBDA (PAIRS)
		  (PROGN
		    ([LAMBDA (AVOID ANS)
			(MAPCONC
			  POSS
			  [FUNCTION (LAMBDA (I)
			      ([LAMBDA (Q)
				  (COND
				    (Q (CONS Q NIL]
				(PROGN
				  (COND
				    ((CAR (MEMBER (CAR I)
						  AVOID))
				      (CONS AVOID ANS))
				    (T
				      (CONS (CONS (CAR I)
						  AVOID)
					    (CONS (CONS CAND
							(CDR I))
						  ANS]
			  NIL]
		      (CAR PAIRS)
		      (CDR PAIRS]
	      NIL]
	  (CAAR L)
	  (CDAR L])

(PAIRS2
  [LAMBDA (L)                                   (* edited: 
						"29-Sep-82 21:09")
    (COND
      [(NULL L)							       |
	(QUOTE ((NIL]						       |
      (T
	([LAMBDA (CAND POSS)
	    (MAPCONC
	      (PAIRS2 (CDR L))
	      [FUNCTION (LAMBDA (PAIRS)
		  (PROGN
		    ([LAMBDA (AVOID ANS)
			(MAPCONC
			  POSS
			  [FUNCTION (LAMBDA (I)
			      ([LAMBDA (Q)
				  (COND
				    (Q (CONS Q NIL]
				(PROGN
				  (COND
				    ((CAR (MEMBER (CAR I)
						  AVOID))
				      (CONS AVOID ANS))
				    (T
				      (CONS (CONS (CAR I)
						  AVOID)
					    (CONS (CONS (CDR I)
							CAND)
						  ANS]
			  NIL]
		      (CAR PAIRS)
		      (CDR PAIRS]
	      NIL]
	  (CAAR L)
	  (CDAR L])

(MAKE-POSSIBILITY-1
  [LAMBDA (X Y FUN APPLY-CONSTRAINTS CONSTRAINTS NIL-PAIRS)
                                                (* edited: 
						"29-Sep-82 21:30")
    ([LAMBDA (N)
	([LAMBDA (Q)
	    (COND
	      [NIL-PAIRS (MAPC Q (FUNCTION (LAMBDA (I)
				   (RPLACD I (CONS (QUOTE (NIL))       |
						   (CDR I]	       |
	      (Q]
	  (MAPCONC
	    X
	    [FUNCTION (LAMBDA (I)
		(PROGN
		  (SETQ N 0)
		  ([LAMBDA (A)
		      (AND A (OR (NULL CONSTRAINTS)
				 (NULL APPLY-CONSTRAINTS)
				 (BLKAPPLY APPLY-CONSTRAINTS
					   (LIST CONSTRAINTS)))
			   (LIST (CONS I A]
		    (MAPCONC
		      Y
		      [FUNCTION (LAMBDA (J)
			  ([LAMBDA (Q)
			      (COND
				(Q (CONS Q NIL]
			    (PROGN (SETQ N (ADD1 N))
				   (COND
				     ((OR (NULL FUN)
					  (BLKAPPLY FUN
						    (LIST I J)))
				       (CONS N J]
		      NIL]
	    NIL]
      0])

(MAKE-POSSIBILITY-2
  [LAMBDA (X Y FUN APPLY-CONSTRAINTS CONSTRAINTS NIL-PAIRS)
                                                (* edited: 
						"29-Sep-82 21:31")
    ([LAMBDA (N)
	([LAMBDA (Q)
	    (COND
	      [NIL-PAIRS (MAPC Q (FUNCTION (LAMBDA (I)
				   (RPLACD I (CONS (QUOTE (NIL))       |
						   (CDR I]	       |
	      (Q]
	  (MAPCONC
	    X
	    [FUNCTION (LAMBDA (I)
		(PROGN
		  (SETQ N 0)
		  ([LAMBDA (A)
		      (AND A (OR (NULL CONSTRAINTS)
				 (NULL APPLY-CONSTRAINTS)
				 (BLKAPPLY APPLY-CONSTRAINTS
					   (LIST CONSTRAINTS)))
			   (LIST (CONS I A]
		    (MAPCONC
		      Y
		      [FUNCTION (LAMBDA (J)
			  ([LAMBDA (Q)
			      (COND
				(Q (CONS Q NIL]
			    (PROGN (SETQ N (ADD1 N))
				   (COND
				     ((OR (NULL FUN)
					  (BLKAPPLY FUN
						    (LIST J I)))
				       (CONS N J]
		      NIL]
	    NIL]
      0])

(PAIRX
  [LAMBDA (I)                                                                   (* jsb: "29-Sep-82 20:46")
    (AND (PROGN (COND												       |
		  [MUST-APPEAR 											       |
														       |
          (* (*CATCH (QUOTE OUT) (PROGN (MAPC I (FUNCTION (LAMBDA (I) (COND ((MEMBER (CDR I) MUST-APPEAR) 	       |
	  (*THROW (QUOTE OUT) T)))))) NIL)) We implement the *CATCH and *THROW using NLSETQ and ERROR!.		       |
	  If the *THROW is ever executed then the *CATCH returns T, otherwise it will return NIL.		       |
	  In INTERLISP, if ERROR! is called the surrounding NLSETQ is exited with value NIL, otherwise NLSETQ 	       |
	  returns the LIST of the value. Hence (NOT (NLSETQ --)) is equivalent to the original construct.)	       |
														       |
														       |
			       (NOT (NLSETQ (MAPC I (FUNCTION (LAMBDA (I)					       |
						      (COND							       |
							((MEMBER (CDR I)					       |
								 MUST-APPEAR)					       |
							  (ERROR!]						       |
		  (T)))												       |
	 (LIST I])

(PAIRY
  [LAMBDA (I)                                                                   (* jsb: "29-Sep-82 20:46")
    (COND													       |
      ((OR (NOT MUST-APPEAR)											       |
	   (for Z in I thereis (MEMBER (CDR I)									       |
				       MUST-APPEAR)))								       |
	(LIST I])
)

(RPAQQ RPGVARS (A B))

(RPAQQ A ((1 2)
	  (7 8)
	  (9 0)
	  (a b c)
	  (a b c)
	  (d e f)
	  (d e f)
	  (g h i)
	  (g h i)
	  (j k l)
	  (m n o)
	  (p q r)))

(RPAQQ B ((a b c)
	  (j k l)
	  (d e f)
	  (p q r)
	  (g h i)
	  (9 0)
	  (a b c)
	  (p q r)
	  (7 8)
	  (j k l)
	  (2 1)
	  (3 2)
	  (8 7)
	  (9 8)
	  (0 9)
	  (m n o)
	  (d e f)
	  (j k l)
	  (m n o)
	  (d e f)
	  (p q r)
	  (g h i)))

(RPAQQ RPGBLOCKS ((PAIRSBBLOCK PAIRS PAIRX PAIRS1 PAIRS2 
			       MAKE-POSSIBILITY-1 MAKE-POSSIBILITY-2
			       (ENTRIES PAIRS)
			       (SPECVARS MUST-APPEAR))))
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: PAIRSBBLOCK PAIRS PAIRX PAIRS1 PAIRS2 MAKE-POSSIBILITY-1 
	MAKE-POSSIBILITY-2 (ENTRIES PAIRS)
	(SPECVARS MUST-APPEAR))
]
(DECLARE: DONTCOPY
  (FILEMAP (NIL (398 5581 (PAIRS 410 . 920) (PAIRS1 924 . 1663) (PAIRS2 
1667 . 2406) (MAKE-POSSIBILITY-1 2410 . 3299) (MAKE-POSSIBILITY-2 3303 .
 4192) (PAIRX 4196 . 5266) (PAIRY 5270 . 5578)))))
STOP